Pascal Super Library/Pascal Super Library (CW International)(1997).bin/COMPILER/VP10B003/VPC.ZIP/SOURCE/RTL/WINDOS.PAS

Pascal/Delphi Source File | 1995-06-22 | 16KB | 455 lines

{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█                                                       █}
{█      Virtual Pascal Runtime Library.  Version 1.0.    █}
{█      OS/2 Presentation Manager DOS interface unit     █}
{█      ─────────────────────────────────────────────────█}
{█      Copyright (C) 1995 B&M&T Corporation             █}
{█      ─────────────────────────────────────────────────█}
{█      Written by Vitaly Miryanov                       █}
{█                                                       █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}

{$S-,R-,Q-,I-,Cdecl-,OrgName-,AlignRec-}

unit WinDos;

interface

uses Use32;

const

{ Flags bit masks }

  fCarry     = $0001;
  fParity    = $0004;
  fAuxiliary = $0010;
  fZero      = $0040;
  fSign      = $0080;
  fOverflow  = $0800;

{ File mode magic numbers }

  fmClosed = $A55AD7B0;
  fmInput  = $A55AD7B1;
  fmOutput = $A55AD7B2;
  fmInOut  = $A55AD7B3;

{ File attribute constants }

  faReadOnly  = $01;
  faHidden    = $02;
  faSysFile   = $04;
  faVolumeID  = $08;    { For compatibility only, OS/2 doesn't use this attribute }
  faDirectory = $10;
  faArchive   = $20;
  faAnyFile   = $37;

{ Maximum file name component string lengths }

const
  fsPathName  = 259;
  fsDirectory = 255;
  fsFileName  = 255;
  fsExtension = 255;

{ FileSplit return flags }

const
  fcExtension = $0001;
  fcFileName  = $0002;
  fcDirectory = $0004;
  fcWildcards = $0008;

{ Typed-file and untyped-file record }

type
  TFileRec = record
    Handle:   Longint;                  { File Handle                }
    Mode:     Longint;                  { Current file mode          }
    RecSize:  Longint;                  { I/O operation record size  }
    Private:  array [1..28] of Byte;    { Reserved                   }
    UserData: array [1..8] of Byte;     { User data area             }
    Name:     array [0..259] of Char;   { File name (ASCIIZ)         }
  end;

{ Textfile record }

type
  PTextBuf = ^TTextBuf;
  TTextBuf = array[0..127] of Char;
  TTextRec = record
    Handle:    Longint;                 { File Handle                }
    Mode:      Longint;                 { Current file mode          }
    BufSize:   Longint;                 { Text File buffer size      }
    BufPos:    Longint;                 { Buffer current position    }
    BufEnd:    Longint;                 { Buffer ending position     }
    BufPtr:    ^TTextBuf;               { Pointer to the buffer      }
    OpenFunc:  Pointer;                 { Open Text File function @  }
    InOutFunc: Pointer;                 { In/Out ...                 }
    FlushFunc: Pointer;                 { Flush ...                  }
    CloseFunc: Pointer;                 { Close ...                  }
    UserData:  array [1..8] of Byte;    { User data area             }
    Name:      array [0..259] of Char;  { File name (ASCIIZ)         }
    Buffer:    TTextBuf;                { Default I/O buffer         }
  end;

{ Search record used by FindFirst and FindNext }

type
  TSearchRec = record
    HDir: Longint;
    Attr: Byte;
    Time: Longint;
    Size: Longint;
    Name: array[0..fsFileName] of Char;
  end;

{ Date and time record used by PackTime and UnpackTime }

type
  TDateTime = record
    Year, Month, Day, Hour, Min, Sec: Word;
  end;

{ Error status variable }

var
  DosError: Integer;

function DosVersion: Word;
procedure GetDate(var Year, Month, Day, DayOfWeek: Word);
procedure SetDate(Year, Month, Day: Word);
procedure GetTime(var Hour, Minute, Second, Sec100: Word);
procedure SetTime(Hour, Minute, Second, Sec100: Word);
procedure GetVerify(var Verify: Boolean);
procedure SetVerify(Verify: Boolean);
function DiskFree(Drive: Byte): Longint;
function DiskSize(Drive: Byte): Longint;
procedure GetFAttr(var F; var Attr: Word);
procedure SetFAttr(var F; Attr: Word);
procedure GetFTime(var F; var Time: Longint);
procedure SetFTime(var F; Time: Longint);
procedure FindFirst(Path: PChar; Attr: Word; var F: TSearchRec);
procedure FindNext(var F: TSearchRec);
procedure UnpackTime(P: Longint; var T: TDateTime);
procedure PackTime(var T: TDateTime; var P: Longint);
function FileSearch(Dest, Name, List: PChar): PChar;
function FileExpand(Dest, Name: PChar): PChar;
function FileSplit(Path, Dir, Name, Ext: PChar): Word;
function GetCurDir(Dir: PChar; Drive: Byte): PChar;
procedure SetCurDir(Dir: PChar);
procedure CreateDir(Dir: PChar);
procedure RemoveDir(Dir: PChar);
function GetArgCount: Integer;
function GetArgStr(Dest: PChar; Index: Integer; MaxLen: Word): PChar;
function GetEnvVar(VarName: PChar): PChar;

{ The following procedures are not implemented

procedure Intr(IntNo: Byte; var Regs: TRegisters);
procedure MsDos(var Regs: TRegisters);
procedure GetCBreak(var Break: Boolean);
procedure SetCBreak(Break: Boolean);
procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
procedure SetIntVec(IntNo: Byte; Vector: Pointer);

}

{ The following procedure is added }

procedure FindClose(var F: TSearchRec);

implementation

uses Os2Def, Os2Base, Strings;

type
  DateTime = TDateTime;
  FileRec  = TFileRec;

{$I DOS.INC}    { Common Dos and WinDos procedures and functions }

{ Searches the specified (or current) directory for the first entry     }
{ that matches the specified filename and attributes. The result is     }
{ returned in the specified search record. Errors (and no files found)  }
{ are reported in DosError.                                             }

procedure FindFirst(Path: PChar; Attr: Word; var F: TSearchRec);
var
  Count: ULong;
  SR: FileFindBuf3;
begin
  Count := 1;
  F.HDir := hdir_Create;
  DosError := DosFindFirst(Path,F.HDir,Attr,SR,SizeOf(SR),Count,fil_Standard);
  if DosError = 0 then
    with F,SR do
    begin
      Attr := attrFile;
      DateTimeRec(Time).FTime := ftimeLastWrite;
      DateTimeRec(Time).FDate := fdateLastWrite;
      Size := cbFile;
      StrPCopy(Name, achName);
    end;
end;

{ Returs the next entry that matches the name and attributes specified  }
{ in a previous call to FindFirst. The search record must be one passed }
{ to FindFirst. Errors (and no more files) are reported in DosError.    }

procedure FindNext(var F: TSearchRec);
var
  Count: ULong;
  SR: FileFindBuf3;
begin
  Count := 1;
  DosError := DosFindNext(F.HDir,SR,SizeOf(SR),Count);
  if DosError = 0 then
    with F,SR do
    begin
      Attr := attrFile;
      DateTimeRec(Time).FTime := ftimeLastWrite;
      DateTimeRec(Time).FDate := fdateLastWrite;
      Size := cbFile;
      StrPCopy(Name, achName);
    end;
end;

{ Ends the search, closes the search record. FindClose should be issued }
{ whenever search record is no longer needed. Unlike DOS, OS/2 does not }
{ keep search information in the user program space (in the SearchRec). }
{ OS/2 returns only handle that identifies this information, so it      }
{ should be freed, otherwise OS/2 runs out of search handles and all    }
{ calls to FindFirst later on will fail. If search record is invalid    }
{ then error is reported in DosError.                                   }

procedure FindClose(var F: TSearchRec);
begin
  DosError := DosFindClose(F.HDir);
end;

{ FileSearch searches for the file given by Name in the list of         }
{ directories given by List. The directory paths in List must be        }
{ separated by semicolons. The search always starts with the current    }
{ directory of the current drive. If the file is found, FileSearch      }
{ stores a concatenation of the directory path and the file name in     }
{ Dest. Otherwise FileSearch stores an empty string in Dest. The        }
{ maximum length of the result is defined by the fsPathName constant.   }
{ The returned value is Dest.                                           }

function FileSearch(Dest, Name, List: PChar): PChar;
var
  Info: FileStatus3;
begin
  if (DosQueryPathInfo(Name,fil_Standard,Info,SizeOf(Info)) = 0)
    and ((Info.attrFile and faDirectory) = 0) then FileExpand(Dest, Name)
 else
  if DosSearchPath(dsp_ImpliedCur+dsp_IgnoreNetErr,List,Name,Dest,fsPathName+1) <> 0
    then Dest[0] := #0;
  FileSearch := Dest;
end;

{ FileExpand fully expands the file name in Name, and stores the result }
{ in Dest. The maximum length of the result is defined by the           }
{ fsPathName constant. The result is an all upper case string           }
{ consisting of a drive letter, a colon, a root relative directory path,}
{ and a file name. Embedded '.' and '..' directory references are       }
{ removed. The returned value is Dest.                                  }

function FileExpand(Dest, Name: PChar): PChar;
var
  I,J,L: Integer;
  C: Char;
  CurDir: String;

procedure AdjustPath;
begin
  { Check for '\.\' }
  if (Dest[J-2] = '\') and (Dest[J-1] = '.') then Dec(J,2)
 else
  { Check for '\..\' }
  if (Dest[J-3] = '\') and (Dest[J-2] = '.') and (Dest[J-1] = '.') then
  begin
    Dec(J,3);
    if Dest[J-1] <> ':' then
    repeat
      Dec(J);
    until Dest[J] = '\';
  end;
end;

begin
  L := StrLen(Name);
  if (L >= 2) and (Name[1] = ':') then
  begin                         { Path is already in form 'X:\Path'     }
    if (L >= 3) and (Name[2] = '\') then StrCopy(Dest, Name)
   else
    begin                       { Path is in form 'X:Path'              }
      GetDir(Ord(UpCase(Name[0])) - Ord('A') + 1, CurDir);
      if Length(CurDir) > 3 then CurDir := CurDir + '\';
      StrLCat(StrPCopy(Dest, CurDir), @Name[2], fsPathName);
    end;
  end
 else
  begin                         { Path is without drive letter          }
    GetDir(0,CurDir);           { Get default drive & directory         }
    if Length(CurDir) > 3 then CurDir := CurDir + '\';
    if Name[0] = '\' then StrLCopy(Dest, @CurDir[1], 2) { only 'X:'     }
                     else StrPCopy(Dest, CurDir);
    StrLCat(Dest, Name, fsPathName);
  end;
  I := 0; J := 0;
  for I := 0 to StrLen(Dest)-1 do
  begin
    C := UpCase(Dest[I]);
    if C = '\' then AdjustPath;
    Dest[J] := C;
    Inc(J);
  end;
  AdjustPath;
  if Dest[J-1] = ':' then
  begin
    Dest[J] := '\';
    Inc(J);
  end;
  Dest[J] := #0;
  FileExpand := Dest;
end;

{ FileSplit splits the file name specified by Path into its three       }
{ components. Dir is set to the drive and directory path with any       }
{ leading and trailing backslashes, Name is set to the file name, and   }
{ Ext is set to the extension with a preceding period. If a component   }
{ string parameter is NIL, the corresponding part of the path is not    }
{ stored. If the path does not contain a given component, the returned  }
{ component string is empty. The maximum lengths of the strings         }
{ returned in Dir, Name, and Ext are defined by the fsDirectory,        }
{ fsFileName, and fsExtension constants. The returned value is a        }
{ combination of the fcDirectory, fcFileName, and fcExtension bit masks,}
{ indicating which components were present in the path. If the name or  }
{ extension contains any wildcard characters (* or ?), the fcWildcards  }
{ flag is set in the returned value.                                    }

function FileSplit(Path, Dir, Name, Ext: PChar): Word;
var
  DirLen, NameLen, Flags: Word;
  NamePtr, ExtPtr: PChar;
begin
  NamePtr := StrRScan(Path, '\');
  if NamePtr = nil then NamePtr := StrRScan(Path, ':');
  if NamePtr = nil then NamePtr := Path else Inc(NamePtr);
  ExtPtr := StrScan(NamePtr, '.');
  if ExtPtr = nil then ExtPtr := StrEnd(NamePtr);
  DirLen := NamePtr - Path;
  if DirLen > fsDirectory then DirLen := fsDirectory;
  NameLen := ExtPtr - NamePtr;
  if NameLen > fsFilename then NameLen := fsFilename;
  Flags := 0;
  if (StrScan(NamePtr, '?') <> nil) or (StrScan(NamePtr, '*') <> nil) then
    Flags := fcWildcards;
  if DirLen <> 0 then Flags := Flags or fcDirectory;
  if NameLen <> 0 then Flags := Flags or fcFilename;
  if ExtPtr[0] <> #0 then Flags := Flags or fcExtension;
  if Dir <> nil then StrLCopy(Dir, Path, DirLen);
  if Name <> nil then StrLCopy(Name, NamePtr, NameLen);
  if Ext <> nil then StrLCopy(Ext, ExtPtr, fsExtension);
  FileSplit := Flags;
end;

{ GetCurDir returns the current directory of a specified drive.         }
{ Drive = 0 indicates the current drive, 1 indicates drive A, 2         }
{ indicates drive B, and so on. The string returned in Dir always       }
{ starts with a drive letter, a colon, and a backslash. The maximum     }
{ length of the resulting string is defined by the fsDirectory constant.}
{ The returned value is Dir. Errors are reported in DosError.           }

function GetCurDir(Dir: PChar; Drive: Byte): PChar;
var
  S: String;
begin
  GetDir(Drive, S);
  ChDir(S);
  DosError := IOResult;
  GetCurDir := StrPCopy(Dir, S);
end;

{ SetCurDir changes the current directory to the path specified by Dir. }
{ If Dir specifies a drive letter, the current drive is also changed.   }
{ Errors are reported in DosError.                                      }

procedure SetCurDir(Dir: PChar);
begin
  ChDir(StrPas(Dir));
  DosError := IOResult;
end;

{ CreateDir creates a new subdirectory with the path specified by Dir.  }
{ Errors are reported in DosError.                                      }

procedure CreateDir(Dir: PChar);
begin
  MkDir(StrPas(Dir));
  DosError := IOResult;
end;

{ RemoveDir removes the subdirectory with the path specified by Dir.    }
{ Errors are reported in DosError.                                      }

procedure RemoveDir(Dir: PChar);
begin
  RmDir(StrPas(Dir));
  DosError := IOResult;
end;

{ GetArgCount returns the number of parameters passed to the program on }
{ the command line.                                                     }

function GetArgCount: Integer;
begin
  GetArgCount := ParamCount;
end;

{ GetArgStr returns the Index'th parameter from the command line, or an }
{ empty string if Index is less than zero or greater than GetArgCount.  }
{ If Index is zero, GetArgStr returns the filename of the current       }
{ module. The maximum length of the string returned in Dest is given by }
{ the MaxLen parameter. The returned value is Dest.                     }

function GetArgStr(Dest: PChar; Index: Integer; MaxLen: Word): PChar;
var
  S: String;
begin
  if MaxLen > 255 then MaxLen := 255;
  S := ParamStr(Index);
  if Length(S) > MaxLen then S[0] := Chr(MaxLen);
  GetArgStr := StrPCopy(Dest, S);
end;

{ GetEnvVar returns a pointer to the value of a specified environment   }
{ variable, i.e. a pointer to the first character after the equals sign }
{ (=) in the environment entry given by VarName. VarName is case        }
{ insensitive. GetEnvVar returns NIL if the specified environment       }
{ variable does not exist.                                              }

function GetEnvVar(VarName: PChar): PChar;
var
  L: Word;
  P: PChar;
begin
  L := StrLen(VarName);
  P := Environment;
  while P^ <> #0 do
  begin
    if (StrLIComp(P, VarName, L) = 0) and (P[L] = '=') then
    begin
      GetEnvVar := P + L + 1;
      Exit;
    end;
    Inc(P, StrLen(P) + 1);
  end;
  GetEnvVar := nil;
end;

end.